home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
asg53.zip
/
DEMO.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-12-03
|
14KB
|
401 lines
{BlueBag, AtSayGet & ReadASG unit demonstration. Each new feature demon-
strated in the source code is followed by the word DEMO so you can examine
how it is used. Not all the procedures are demonstrated but there is a good
representation. Read the *.DOC files for a listing of all of the available
functions and procedures.}
PROGRAM Demo;
{$V-}
USES
CRT, { For TPCRT get source code and recompile }
BlueBag,
AtSayGet,
ReadASG;
TYPE
PhoneType = STRING[14];
VAR
AllOK : BOOLEAN;
B : BYTE;
C : CHAR;
DS1,
DS2 : DateString;
Dt1,
Dt2 : Date;
BigDt : DelimitedDate;
Change: LONGINT;
Str10 : STRING[10];
AnyS : STRING;
Doc : TEXT;
Any : WORD;
CONST
Cont : BOOLEAN =True;
Phone : PhoneType='( ) - ';
AR : REAL =0.0;
LI : LONGINT =0;
I : INTEGER =0;
W : WORD =0;
{$I RASGDEMO.INC} { <--- LOOK AT THIS TO SEE HOW READASG.TPU IS USED}
{$I R2ENGLSH.INC}
BEGIN
TextAttr:=7; ClrScr;
OrgAttr:=7; SayAttr:=7; GetAttr:=30; EndAttr:=15;
DrawBox(23,1,55,3,3); {DEMO}
AtSay(25,2,'AtSayGet and BlueBag TPU Demo'); {DEMO}
DrawBox(1,4,80,21,2);
AtSay(3,5,'If you like boxes but find them a fuss you''ll love DrawBox()');
AtSay(3,7,'We have regular boxes...');
DrawBox(28,7,38,10,1); Delay(500);
DrawBox(41,7,51,10,2); Delay(500);
DrawBox(54,7,64,10,3); Delay(500);
DrawBox(67,7,77,10,4); Delay(500);
AtSay(3,12,'and lots of others.....');
DrawBox(28,12,38,15,176); Delay(500);
DrawBox(41,12,51,15,177); Delay(500);
DrawBox(54,12,64,15,178); Delay(500);
DrawBox(67,12,77,15,219); Delay(500);
DrawBox(28,17,38,20,36); Delay(500);
DrawBox(41,17,51,20,63); Delay(500); INC(TextAttr,Blink);
DrawBox(54,17,64,20,248); Delay(500); DEC(TextAttr,Blink);
DrawBox(67,17,77,20,240); Delay(500);
AtSay(2,23,'Sometimes it''s nice to halt everything and just WAIT for the user to');
GoToXY(2,24);
WAIT; {DEMO}
OpenWindow(20,7,78,20,White,Red,1,' WINDOWS '); {DEMO}
WRITELN; WRITELN;
WRITELN(' The image below this window was just saved on the heap.');
WRITELN(' You may have up to 9 windows active at any time. When');
WRITELN(' you close a window the saved image that was below it is');
WRITELN(' quickly restored to the screen and the space it took on');
WRITELN(' the heap is returned to DOS.');
WRITELN; WRITELN;
WRITE(' '); WAIT;
OpenWindow( 3, 1,15,12,LightGray,Blue,2,' 2 '); DELAY(500);
OpenWindow(10, 3,22,14,Yellow,Magenta,3,' 3 '); DELAY(500);
OpenWindow(20, 5,32,16,White,Blue,4,' 4 '); DELAY(500);
OpenWindow(30, 7,42,18,Black,LightGray,176,' 5 '); DELAY(500);
OpenWindow(40, 9,52,20,White,Green,177,' 6 '); DELAY(500);
OpenWindow(50,11,62,22,LightGray,Black,178,' 7 '); DELAY(500);
OpenWindow(60,13,72,24,LightBlue,Blue,240,' 8 '); DELAY(500);
OpenWindow( 6,15,75,19,White+Blink,Black,3,' 9 ');
GoToXY(22,2); WAIT;
CloseWindow; {9} DELAY(500); {DEMO}
CloseWindow; {8} DELAY(500);
CloseWindow; {7} DELAY(500);
CloseWindow; {6} DELAY(500);
CloseWindow; {5} DELAY(500);
CloseWindow; {4} DELAY(500);
CloseWindow; {3} DELAY(500);
CloseWindow; {2} DELAY(500);
CloseWindow; {1} DELAY(1000);
OpenWindow(2,11,30,20,Yellow,Blue,1,'');
AtSay(2,2,'Well, this isn''t pretty!');
AtSay(2,3,'To clear a portion of a');
AtSay(2,4,'screen or window use the');
AtSay(2,5,'CLEAR() procedure...');
AtSay(2,7,''); WAIT;
CloseWindow;
CLEAR(2,5,79,20); {DEMO}
ReverseVideo; {DEMO}
CLEAR(1,22,80,24);
Center(23,'MORE CRT TRICKS'); {DEMO}
CENTER(6,'This is what the REVERSEVIDEO procedure did to me!');
RestoreVideo; {DEMO}
CENTER(7,'This is what the RESTOREVIDEO procedure did to me.');
GoToXY(28,8); WAIT; CLEAR(14,6,70,8);
Center(7,'The CENTER() procedure centers long lines of text on the screen');
DELAY(1000);
Center(8,'It also centers shorter lines like this one'); DELAY(1000);
Center(9,'And me too!'); DELAY(1000);
OpenWindow(5,11,50,17,White,Green,1,'');
Center(2,'It works in windows');
GoToXY(2,4); Wait;
CloseWindow;
CLEAR(5,7,70,9);
ReverseVideo; CENTER(23,'CURSOR MANIPULATION'); RestoreVideo;
{ demonstrate cursor manipulation }
CursorOff; {DEMO}
AtSay(26,10,'Heh...Where''s the cursor?'); Delay(2000);
CursorOn; {DEMO}
SetCursor(0,StopScan); {DEMO}
AtSay(23,11,'Isn''t this a bit over doing it?'); Delay(2000);
RestoreCursor; {DEMO}
CLEAR(23,10,70,11);
SayAttr:=30; {DEMO}
AtSay(23,10,'PRESS A KEY TO CHANGE CURSOR SIZE');
SayAttr:=7;
AtSay(15,12,'Notice the various cursor sizes/shapes available:');
FOR Any:=StopScan DOWNTO 1 DO
BEGIN
SetCursor(0,Any); {Variations on the theme}
C:=ReadKey;
END;
CursorOn; {Reset to system default}
CursorSave;
FOR Any:=StopScan-1 DOWNTO 0 DO
BEGIN
SetCursor(Any,StopScan); {More variations}
C:=ReadKey;
END;
CursorOn; CursorSave;
CLEAR(15,10,70,12);
ReverseVideo; CENTER(23,' STRING ROUTINES '); RestoreVideo;
AtSay(8,9,'NOTE: You can use the WordStar/dBase/Turbo editing keys');
AnyS:='Please enter a line of text in lower case and press Enter:';
AtSayGetStrLen(8,12,'',AnyS,Length(AnyS)); {DEMO}
AtSay(8,14,'This demonstrates the UpperCase() Function:');
AnyS:=UpperCase(AnyS); {DEMO}
AtSay(8,15,AnyS);
GoToXY(8,17); WAIT;
CLEAR(2,10,79,17);
AnyS:='PLEASE ENTER A LINE OF TEXT IN UPPER CASE AND PRESS ENTER:';
AtSayGetStrLen(8,12,'',AnyS,Length(AnyS));
AtSay(8,14,'This demonstrates the LowerCase() Function:');
AnyS:=LowerCase(AnyS); {DEMO}
AtSay(8,15,AnyS);
GoToXY(8,17); WAIT;
CLEAR(2,9,79,17);
AtSay(3,8,'The sentance that you entered was:');
AtSay(3,9,AnyS);
AtSay(3,11,'After NoBlanks() takes care of your line it looks like this:');
NoBlanks(AnyS); {DEMO}
AtSay(3,12,AnyS);
GoToXY(3,15); WAIT;
CLEAR(2,8,79,15);
AnyS:='Please enter a line of text in ANY case and press Enter:';
AtSayGetStrLen(8,12,'',AnyS,Length(AnyS));
GetWordCount(AnyS,B); {DEMO}
OpenWindow(2,5,39,20,White,Green,1,' FORWARD ');
FOR Any:=1 TO B DO WRITELN(NextWord(AnyS)); {DEMO}
OpenWindow(40,5,79,20,White,Red,1,' BACKWARDS ');
FOR Any:=B DOWNTO 1 DO WRITELN(NthWord(AnyS,Any)); {DEMO}
WAIT;
CloseWindow; {backwards}
CloseWindow; {forward}
CLEAR(8,11,75,12);
ReverseVideo; CENTER(23,' AtSayGet DEMO '); RestoreVideo;
AtSay(10, 7,'The AtSayGet unit provides the functional equivalence of the');
AtSay(10, 8,'dBase: @ Line,Row SAY "prompt" GET <var> [PICTURE] [RANGE]');
AtSay(10, 9,'command. A full range of editing keys are employed. See the');
AtSay(10,10,'ATSAYGET.DOC file for details.');
AtSayGetBoolean(4,12,'Continue?',Cont); {DEMO}
WRITELN;
IF NOT Cont THEN
BEGIN
AtSay(14,12,'I insist!'); Delay(2000);
END;
Clear(4,7,75,12); AnyS:='';
REPEAT
AtSay(4,7,'Do not leave this field blank, or else!'); {you won't ever finish}
AtSayGetStrLen(4,8,'What is your name?',AnyS,30); {DEMO}
UNTIL NOT IsBlank(AnyS); {DEMO}
CLEAR(4,7,75,8);
AtSayGetWord (4, 8,'What is your age? ',W,2); {DEMO}
AtSayGetStrPic(4, 9,'What is your phone',Phone,'(999) 999-9999'); {DEMO}
AtSayGetInt (4,10,'Enter an Integer ',I,5); {DEMO}
I:=0;
{DEMO of TRIM() function follows}
AtSay(4,12,Concat('O.K. ',TRIM(AnyS),', let''s not have any negative numbers!'));
{the following shows some of the ASGRange procedures}
AtSayGetIntRange(4,13,'What do you owe on your car?',I,6,0,MaxInt); {DEMO}
AtSayGetLongIntRange(4,14,'What is owing on your house?',LI,7,0,250000); {DEMO}
AtSayGetRealRange(4,15,'What are your living costs? ',AR,10,2,500,5000); {DEMO}
GoToXY(4,19); Wait;
CLEAR(4,8,75,19);
ReverseVideo; CENTER(23,'DEVICE FUNCTIONS'); RestoreVideo;
OpenWindow(13,10,68,18,LightGray,Blue,3,' DEVICE FUNCTIONS ');
Cont:=True;
WHILE Cont DO
BEGIN
ClrScr; WRITELN;
FOR W:=0 TO 2 DO
BEGIN
WRITE(' Your printer #',W+1:2,' is ');
IF NOT PrinterOnLine(W) {DEMO}
THEN
BEGIN
TextColor(White); WRITE('NOT '); TextColor(LightGray);
END;
WRITELN('on-line');
END;
AtSayGetBoolean(2,6,'Try again?',Cont);
END;
ClrScr;
AnyS:='BLUEBAG.DOC '; Cont:=True;
WHILE Cont DO
BEGIN
ClrScr;
AtSayGetStrLen(2,2,'Enter a file name',AnyS,12); GoToXY(2,4);
WRITE(Trim(AnyS));
IF OnFile(AnyS) THEN WRITELN(' is on file.') ELSE WRITELN(' is NOT on file.');
{DEMO ^}
AtSayGetBoolean(2,5,'Try again?',Cont);
END;
ClrScr; Cont:=True;
AtSayGetBoolean(2,3,'Read the documentation now?',Cont); WRITELN;
IF Cont THEN
BEGIN
IF OnFile('BLUEBAG.DOC') OR OnFile('ATSAYGET.DOC') THEN
BEGIN
OpenWindow(1,1,80,24,LightGray,Black,1,' DOCUMENTATION ');
IF OnFile('BLUEBAG.DOC') THEN
BEGIN
ASSIGN(Doc,'BLUEBAG.DOC'); RESET(Doc); I:=1;
WHILE NOT EOF(Doc) DO
BEGIN
Readln(Doc,AnyS); WRITELN(AnyS); INC(I);
IF I=21 THEN
BEGIN
WRITE(' '); WAIT; GoToXY(1,WhereY); ClrEol; I:=1;
END;
END;
CLOSE(Doc); WRITE(' '); WAIT; ClrScr;
END
ELSE
BEGIN
WRITELN(' BLUEBAG.DOC IS NOT ON FILE.'); WRITE(' '); WAIT;
END;
ClrScr;
IF OnFile('ATSAYGET.DOC') THEN
BEGIN
ASSIGN(Doc,'ATSAYGET.DOC'); RESET(Doc); I:=1;
WHILE NOT EOF(Doc) DO
BEGIN
Readln(Doc,AnyS); WRITELN(AnyS); INC(I);
IF I=21 THEN
BEGIN
WRITE(' '); WAIT; GoToXY(1,WhereY); ClrEol; I:=1;
END;
END;
CLOSE(Doc); WRITE(' '); WAIT; ClrScr;
END
ELSE
BEGIN
WRITELN(' ATSAYGET.DOC IS NOT ON FILE.'); WRITE(' '); WAIT;
END;
CloseWindow;
END
ELSE
BEGIN
WRITELN(' Rats, both document files are missing!'); Wait;
END;
END;
CloseWindow; {device}
{show some of the date features}
ReverseVideo; CENTER(23,'BLUEBAG DATE DEMO'); RestoreVideo;
OpenWindow(12,5,68,19,LightGray,Blue,4,' DATE FEATURES ');
ClrScr; AllOK:=False;
Dt2:=SysDate; {DEMO}
Ds2:=DateToDateString(Dt2); {DEMO}
WRITELN(' Today is ',NameOfDay(DayOfWeek(Dt2)),', ',NameOfMonth(MonthOfYear(Dt2)),
' ',COPY(Ds2,3,2),', ',COPY(Ds2,5,4)); {DEMO of 2 functions}
REPEAT
BigDt:=' / / ';
AtSayGetStrPic(2,2,'Enter Birth Day as Mo/Dy/Year:',BigDt,'99/99/9999');
WRITELN;
Ds1:=StripDateString(BigDt); {DEMO}
Dt1:=DateStringToDate(Ds1); {DEMO}
IF Dt1<>BadDate THEN AllOK:=True ELSE
BEGIN
WRITELN(' You entered an invalid date. Please try again.');
WRITE(' '); WAIT; CLEAR(1,2,48,4);
END;
UNTIL AllOK;
WRITELN(' You were born on a ',NameOfDay(DayOfWeek(Dt1)));
WRITELN(' Gosh, that was ',DaysBetween(Dt1,Dt2),' days ago!');
Any:=Trunc((Dt2-Dt1) / 365.25);
WRITE(' You were ',Any,' years old ');
WRITELN((Dt2-Dt1)-Trunc(Any*365.25),' days ago.'); Dt1:=0;
AtSayGetLongIntRange(2,7,'Enter some number of days hence: ',Dt1,6,1,999999);
WRITELN;
IncDate(Dt2,Dt1); {DEMO}
Ds2:=DateToDateString(Dt2);
BigDt:=DelimitDateString(DS2); {DEMO}
WRITELN(' The date that is ',Dt1,' days from now is ',BigDt);
WRITELN(' That will be a ',NameOfDay(DayOfWeek(Dt2)),' in ',NameOfMonth(MonthOfYear(Dt2)));
WRITELN;
WRITELN(' These date routines are only usefull until ',
DelimitDateString(DateToDateString(3652499)));
WRITELN(' Sorry.'); WRITE(' '); WAIT;
CloseWindow; {Date Features}
ReverseVideo; CENTER(23,'FULL SCREEN EDITING'); RestoreVideo;
{the following demonstrates the procedures in the ReadASG.TPU ... Look
at the code in RASGDEMO.INC for details of usage }
OpenWindow(1,4,80,21,LightGray,Black,2,'');
Init;
REPEAT
ClrScr;
AtSay(5,1,'The full screen can be edited using cursor & tab keys.');
IF NOT AddInfo THEN
BEGIN {editing a file record}
BlankInfo; READ(InfoFile,InfoRec);
IF EOF(InfoFile) THEN AddInfo:=True;
SEEK(InfoFile,FilePos(InfoFile)-1);
END
ELSE
BEGIN
BlankInfo;
AtSayGetBoolean(5,3,'Adding a business record?',InfoRec.Business);
END;
IF InfoRec.Business THEN
BEGIN
ReadPage(2);
OpenWindow(20,5,60,11,White,Red,1,' FINANCIAL INFORMATION ');
ReadPage(3);
CloseWindow; {financial information}
SayAttr:=7; OrgAttr:=7;
END
ELSE ReadPage(1);
WRITE(InfoFile,InfoRec);
IF AddInfo THEN AtSayGetBoolean(2,16,'Add a record?',More)
ELSE AtSayGetBoolean(2,16,'Edit next record?',More);
IF NOT More THEN
BEGIN
CLOSE(InfoFile); Cont:=False;
END;
UNTIL NOT Cont;
FOR C1:=3 DOWNTO 1 DO FreeASGHeapPage(C1);
A1:=0; A2:=0; C1:=0; C2:=0; FillChar(CA,SizeOf(CA),0);
ClrScr;
WRITELN('The following demonstrates how to reuse an ASG Page. It also gives an example');
WRITELN('of how to add fields to a page at runtime depending upon variable criteria...');
WRITELN('See the program CVP.EXE in CVP22.ARC located in BPA0 for a usefull applic''n.');
{re-set ASG attributes}
OrgAttr:=7; SayAttr:=7; GetAttr:=113; EndAttr:=15;
AtSayGetWordRange(1,5,'Enter a number of columns from 2 to 5:',C2,1,2,5);
AtSayGetWordRange(1,6,'Enter a number of rows from 2 to 5 :',C1,1,2,5);
MakeASGHeapPage(1,C1*C2); {you will add Rows*columns of fields to the page}
FOR A1:=1 TO C1 DO FOR A2:=1 TO C2 DO
IF A2=1 THEN AddASGW(1,1,A1+10,'Enter numbers',@CA[A1,A2],2)
ELSE AddASGW(1,((A2-1)*10+15),A1+10,'',@CA[A1,A2],2);
AtSay(15,9,'The screen below can be edited using cursor & tab keys.');
ReadPage(1);
FreeASGHeapPage(1); {this isn't really necessary as ReadASG frees all pages
as part of its exit code}
CloseWindow;
{the following demonstrates the RealToEnglish procedure}
RANDOMIZE; CqNum:=Random(400)+100; TotPd:=0;
IntroScript;
DONE:=False; InReal:=45;
REPEAT
OpenWindow(2,8,79,20,Black,Green,1,'');
ShowCheque; EndAttr:=33;
AtSayGetRealRange(65,5,'$',InReal,9,2,1,999999.99);
RealToEnglish(InReal,OutStr); { <-- THIS IS THE PROCEDURE BEING DEMONSTRATED}
TextAttr:=33; GoToXY(1,7); WRITELN(OutStr:75);
WriteAnotherCheque;
INC(CqNum); TotPd:=TotPd+InReal;
CloseWindow; {cheque}
WRITELN(' Cheque #',CqNum-1:4,' $',InReal:10:2);
InReal:=0;
UNTIL DONE;
PatheticPlea;
TextAttr:=7;
END.